home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / _nonstandard.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  10.6 KB  |  347 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; Non-standard procedures
  6.  
  7. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8.  
  9. (##define-macro (define-macro . rest)
  10.   `(##eval-global '(##define-macro ,@rest)))
  11.  
  12. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  13.  
  14. (define (exit)
  15.   (##quit))
  16.  
  17. (define (error msg . args)
  18.   (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
  19.     (##identify-error #f msg args '())
  20.     (##debug-repl cont))))))
  21.  
  22. (define (eval expr (env))
  23.   (##eval-global expr))
  24.  
  25. (define (compile-file filename . options)
  26.   (touch-vars (filename)
  27.     (check-string filename (compile-file filename . options)
  28.       (let ((cf c#cf))
  29.         (if (##procedure? cf)
  30.           (##apply cf (##cons filename (##cons 'M68000 options)))
  31.           (##runtime-error
  32.             "Compiler is not loaded"
  33.             'compile-file
  34.             (##cons filename options)))))))
  35.   
  36. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  37.  
  38. (define-macro (trace . procs)
  39.  
  40.   (define (tr l)
  41.     (if (##pair? l)
  42.       (let ((var (##car l)))
  43.         (##cons (##list '##TRACE
  44.                         (##list 'QUOTE var)
  45.                         (##list 'LAMBDA '() var)
  46.                         (##list 'LAMBDA '(##VAL) (##list 'SET! var '##VAL)))
  47.                 (tr (##cdr l))))
  48.       '()))
  49.  
  50.   (if (##pair? procs)
  51.     (##cons 'BEGIN (tr procs))
  52.     '(##TRACE-LIST)))
  53.  
  54. (define-macro (untrace . procs)
  55.  
  56.   (define (untr l)
  57.     (if (##pair? l)
  58.       (let ((var (##car l)))
  59.         (##cons (##list '##UNTRACE (##list 'QUOTE var)) (untr (##cdr l))))
  60.       '()))
  61.  
  62.   (if (##pair? procs)
  63.     (##cons 'BEGIN (untr procs))
  64.     '(##UNTRACE-ALL)))
  65.  
  66. (define ##traced '())
  67.  
  68. (define (##trace name getter setter)
  69.  
  70.   (define (add-quotes l)
  71.     (if (##pair? l)
  72.       (let ((x (##car l)))
  73.         (##cons (if (##self-eval? x) x (##list 'QUOTE x))
  74.                 (add-quotes (##cdr l))))
  75.       '()))
  76.  
  77.   (define (traced-proc proc)
  78.     (lambda args
  79.       (let* ((i (##dynamic-ref '##TRACE-INDENT 0))
  80.              (w (if (##fixnum.< 40 i) 0 (##fixnum.- 40 i)))
  81.              (out (##repl-out))
  82.              (call (##cons name (add-quotes args))))
  83.  
  84.         (define (indent i)
  85.           (let loop ((j 0))
  86.             (if (##fixnum.< j i)
  87.               (begin
  88.                 (##write-string (if (##fixnum.= (##fixnum.remainder j 3) 0) "|" " ") out)
  89.                 (loop (##fixnum.+ j 1))))))
  90.  
  91.         (indent i)
  92.         (##write-string "Entry " out)
  93.         (##write-string (##object->string call (##fixnum.+ w 33) (if-touches #t #f)) out)
  94.         (##newline out)
  95.         (let ((result
  96.                 (##dynamic-bind
  97.                   (##list (##cons '##TRACE-INDENT (##fixnum.+ i 1)))
  98.                   (lambda () (##apply proc args)))))
  99.           (indent i)
  100.           (##write-string "==> " out)
  101.           (##write-string (##object->string result (##fixnum.+ w 35) (if-touches #t #f)) out)
  102.           (##newline out)
  103.           result))))
  104.  
  105.   (let ((proc (getter)))
  106.     (if (##procedure? proc)
  107.       (let ((x (##assq name ##traced)))
  108.         (if (##not (and x (##eq? proc (##cadddr x)))) ; being traced already?
  109.           (let ((tproc (traced-proc proc)))
  110.             (if x
  111.               (begin
  112.                 (if (##eq? ((##cadr x)) (##cadddr x)) ; var = traced proc?
  113.                   ((##caddr x) (##car (##cddddr x)))) ; restore old value
  114.                 (##set-car! (##cdr x) getter)
  115.                 (##set-car! (##cddr x) setter)
  116.                 (##set-car! (##cdddr x) tproc)
  117.                 (##set-car! (##cddddr x) proc))
  118.               (set! ##traced
  119.                 (##cons (##list name getter setter tproc proc) ##traced)))
  120.             (setter tproc))))))
  121.   name)
  122.  
  123. (define (##trace-list)
  124.   (let loop ((l1 ##traced) (l2 '()))
  125.     (if (##pair? l1)
  126.       (let ((x (##car l1)))
  127.         (loop (##cdr l1) (##cons (##car x) l2)))
  128.       l2)))
  129.  
  130. (define (##untrace name)
  131.   (let loop ((l1 ##traced) (l2 '()))
  132.     (if (##pair? l1)
  133.       (let ((x (##car l1)))
  134.         (if (##eq? (##car x) name)
  135.           (begin
  136.             (if (##eq? ((##cadr x)) (##cadddr x)) ; var = traced proc?
  137.               ((##caddr x) (##car (##cddddr x)))) ; restore old value
  138.             (set! ##traced (##append (##reverse l2) (##cdr l1)))
  139.             name)
  140.           (loop (##cdr l1) (##cons x l2))))
  141.       name)))
  142.  
  143. (define (##untrace-all)
  144.   (let loop ((l ##traced))
  145.     (if (##pair? l)
  146.       (let ((x (##car l)))
  147.         (##untrace (##car x))
  148.         (loop (##cdr l)))
  149.       ##unprint-object)))
  150.  
  151. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  152.  
  153. (define (set-gc-report report?)
  154.   (set! ##gc-report report?)
  155.   ##unprint-object)
  156.  
  157. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  158.  
  159. (define (open-input-string s)
  160.   (touch-vars (s)
  161.     (check-string s (open-input-string s)
  162.       (##open-input-string s))))
  163.  
  164. (define (open-output-string)
  165.   (##open-output-string))
  166.  
  167. (define (get-output-string p)
  168.   (touch-vars (p)
  169.     (check-output-port p (get-output-string p)
  170.       (check-open-port p (get-output-string p)
  171.         (##get-output-string p)))))
  172.  
  173. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  174.  
  175. (define (with-input-from-string s thunk)
  176.   (touch-vars (s thunk)
  177.     (check-string s (with-input-from-string s thunk)
  178.       (check-procedure thunk (with-input-from-string s thunk)
  179.         (let ((port (##open-input-string s)))
  180.           (##dynamic-bind
  181.             (##list (##cons '##CURRENT-INPUT-PORT port))
  182.             thunk))))))
  183.  
  184. (define (with-output-to-string thunk)
  185.   (touch-vars (thunk)
  186.     (check-procedure thunk (with-output-to-string thunk)
  187.       (let ((port (##open-output-string)))
  188.         (##dynamic-bind
  189.           (##list (##cons '##CURRENT-OUTPUT-PORT port))
  190.           thunk)
  191.         (##get-output-string port)))))
  192.  
  193. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  194.  
  195. (define (with-input-from-port port thunk)
  196.   (touch-vars (port thunk)
  197.     (check-input-port port (with-input-from-port port thunk)
  198.       (check-open-port port (with-input-from-port port thunk)
  199.         (check-procedure thunk (with-input-from-port port thunk)
  200.           (##dynamic-bind (##list (##cons '##CURRENT-INPUT-PORT port)) thunk))))))
  201.  
  202. (define (with-output-to-port port thunk)
  203.   (touch-vars (port thunk)
  204.     (check-output-port port (with-output-to-port port thunk)
  205.       (check-open-port port (with-output-to-port port thunk)
  206.         (check-procedure thunk (with-output-to-port port thunk)
  207.           (##dynamic-bind (##list (##cons '##CURRENT-OUTPUT-PORT port)) thunk))))))
  208.  
  209. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  210.  
  211. (define (pretty-print obj (p) (w))
  212.  
  213.   (define (pretty-print* obj port width)
  214.     (##pretty-print obj port width)
  215.     ##unprint-object)
  216.  
  217.   (if (##unassigned? p)
  218.     (let ((port (##current-output-port)))
  219.       (check-open-port port (pretty-print obj)
  220.         (pretty-print* obj port (##port-width port))))
  221.     (touch-vars (p)
  222.       (if (##unassigned? w)
  223.         (check-output-port p (pretty-print obj p)
  224.           (check-open-port p (pretty-print obj p)
  225.             (pretty-print* obj p (##port-width port))))
  226.         (touch-vars (w)
  227.           (check-output-port p (pretty-print obj p w)
  228.             (check-open-port p (pretty-print obj p w)
  229.               (check-exact-int-non-neg w (pretty-print obj p w)
  230.                 (pretty-print* obj p w)))))))))
  231.  
  232. (define (pp obj (p) (w))
  233.  
  234.   (define (pp* obj port width)
  235.     (if (##procedure? obj)
  236.       (##pretty-print (##decompile obj) port width)
  237.       (##pretty-print obj port width))
  238.     ##unprint-object)
  239.  
  240.   (if (##unassigned? p)
  241.     (let ((port (##current-output-port)))
  242.       (check-open-port port (pp obj)
  243.         (pp* obj port (##port-width port))))
  244.     (touch-vars (p)
  245.       (if (##unassigned? w)
  246.         (check-output-port p (pp obj p)
  247.           (check-open-port p (pp obj p)
  248.             (pp* obj p (##port-width port))))
  249.         (touch-vars (w)
  250.           (check-output-port p (pp obj p w)
  251.             (check-open-port p (pp obj p w)
  252.               (check-exact-int-non-neg w (pp obj p w)
  253.                 (pp* obj p w)))))))))
  254.  
  255. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  256.  
  257. (define (runtime)
  258.   (let ((buf (##make-vector 2 0)))
  259.     (##cpu-times buf)
  260.     (##/ (##vector-ref buf 0) 1000.0)))
  261.  
  262. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  263.  
  264. (define gensym
  265.   (let ((count 0))
  266.     (lambda ((prefix))
  267.       (let ((p (cond ((##unassigned? prefix)
  268.                       "g")
  269.                      ((##symbol? prefix)
  270.                       (symbol-string prefix))
  271.                      ((##string? prefix)
  272.                       prefix)
  273.                      (else
  274.                       "g"))))
  275.         (set! count (##+ count 1))
  276.         (symbol-make (##string-append p (##number->string count 10)))))))
  277.  
  278. (define (get sym prop)
  279.   (touch-vars (sym prop)
  280.     (check-symbol sym (get sym prop)
  281.       (let ((x (##assq prop (symbol-plist sym))))
  282.         (if x
  283.           (##cdr x)
  284.           #f)))))
  285.  
  286. (define (put sym prop val)
  287.   (touch-vars (sym prop)
  288.     (check-symbol sym (put sym prop val)
  289.       (let ((plist (symbol-plist sym)))
  290.         (let ((x (##assq prop plist)))
  291.           (if x
  292.             (##set-cdr! x val)
  293.             (symbol-plist-set! sym (##cons (##cons prop val) plist)))
  294.           ##unprint-object)))))
  295.  
  296. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  297.  
  298. (define (weak-pair? x)
  299.   (touch-vars (x) (##weak-pair? x)))
  300.  
  301. (define (weak-cons x y)
  302.   (##weak-cons x y))
  303.  
  304. (define (weak-car x)
  305.   (touch-vars (x)
  306.     (check-weak-pair x (weak-car x) (##weak-car x))))
  307.  
  308. (define (weak-cdr x)
  309.   (touch-vars (x)
  310.     (check-weak-pair x (weak-cdr x) (##weak-cdr x))))
  311.  
  312. (define (weak-set-car! x y)
  313.   (touch-vars (x)
  314.     (check-weak-pair x (weak-set-car! x y) (##weak-set-car! x y))))
  315.  
  316. (define (weak-set-cdr! x y)
  317.   (touch-vars (x)
  318.     (check-weak-pair x (weak-set-cdr! x y) (##weak-set-cdr! x y))))
  319.  
  320. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  321.  
  322. (define (make-queue)
  323.   (##make-queue))
  324.  
  325. (define (queue-put! q x)
  326.   (touch-vars (q)
  327.     (check-queue q (queue-put! q x) (##queue-put! q x))))
  328.  
  329. (define (queue-get! q)
  330.   (touch-vars (q)
  331.     (check-queue q (queue-get! q) (##queue-get! q))))
  332.  
  333. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  334.  
  335. (define (make-semaphore)
  336.   (##make-semaphore))
  337.  
  338. (define (semaphore-wait s)
  339.   (touch-vars (s)
  340.     (check-semaphore s (semaphore-wait s) (##semaphore-wait s))))
  341.  
  342. (define (semaphore-signal s)
  343.   (touch-vars (s)
  344.     (check-semaphore s (semaphore-signal s) (##semaphore-signal s))))
  345.  
  346. ;------------------------------------------------------------------------------
  347.